home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / 10.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  51KB  |  1,684 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #include "hdr.h"
  11. #include "libhdr.h"
  12. #include "vars.h"
  13. #include "ifile.h"
  14. #include "chapp.h"
  15. #include "setp.h"
  16. #include "smiscp.h"
  17. #include "miscp.h"
  18. #include "libp.h"
  19. #include "libwp.h"
  20. #include "dclmapp.h"
  21. #include "dbxp.h"
  22. #include "errmsgp.h"
  23.  
  24. int save_trace_opt = 0;
  25. /* chapter 10 */
  26.  
  27. static Tuple context;
  28.  
  29. static void init_compunit();
  30. static void save_comp_info(Node);
  31. static void save_tree(Node, int);
  32. static void renumber_nodes(char *);
  33. static void collect_unit_nodes(Symbol);
  34. static void generic_declarations(Symbol, Unitdecl);
  35. static void save_proper_body_info(Node);
  36. static void save_package_instance_unit(Node);
  37. static void save_subprogram_instance_unit(Node);
  38. static void establish_context(Node);
  39. static void with_clause(Tuple, Node);
  40. static void elaborate_pragma(Node);
  41. static Tuple check_separate(Node);
  42. static Stubenv retrieve_env(Node, Node);
  43. static void remove_obsolete_stubs(char *);
  44. static char *get_unit(char *);
  45. static void new_unit_numbers(Node, unsigned);
  46.  
  47. /*TBSL: need to review calls to sasve_subprog_info now that
  48.  * it has an argument    ds 31 oct
  49.  */
  50.  
  51. extern IFILE *TREFILE, *AISFILE, *LIBFILE;
  52. static Tuple  elab_pragmas;
  53.  
  54. /* all_vis is tuple of unit-names */
  55.  
  56. static void init_compunit()                        /*;init_compunit*/
  57. {
  58.     int    i;
  59.  
  60.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  init_compunit;");
  61.  
  62.     /* Initialize tree nodes to unit number of the new compilation unit.*/
  63.     unit_number_now = unit_number(unit_name);
  64.     for (i = 1; i <= seq_node_n; i++)
  65.         N_UNIT((Node)seq_node[i]) = unit_number_now;
  66. }
  67.  
  68. void new_compunit(char *typ, Node name_node)    /*;new_compunit*/
  69. {
  70.     char    *name;
  71.  
  72.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  new_compunit");
  73.  
  74.     name = N_VAL(name_node);
  75.  
  76.     /* Establish global name and library name for new compilation unit. */
  77.     if (IS_COMP_UNIT){
  78.         remove_obsolete_stubs(name);
  79.         seq_symbol_n = 0;     /* reset symbol count */
  80.         unit_name = strjoin(typ, name);
  81.         init_compunit();
  82.     }
  83. }
  84.  
  85. /* chapter 10, part b*/
  86. void compunit(Node node)                            /*;compunit*/
  87. {
  88.     Node    unit_body;
  89.     Tuple    added_names;
  90.     char    *id;
  91.     Fortup    ft1;
  92.     Symbol    sym;
  93.     Fordeclared fd;
  94.  
  95.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  compunit;");
  96.  
  97.     elab_pragmas = tup_new(0);
  98.     stubs_to_write = set_new(0);
  99.     all_vis = tup_new(0);
  100.     /*context_node = N_AST1(node);*/
  101.     unit_body = N_AST2(node);
  102.     establish_context(node);
  103.     /* process unit only if there were no problems in processing context */
  104.     if (context != (Tuple)0)
  105.         adasem(unit_body);
  106.     if (errors == 0) {
  107.         /* If there are no errors in any comp unit in the file, collect global
  108.          * maps and library information after completion of this a compilation
  109.          * unit.
  110.          */
  111.         if (N_KIND(unit_body) == as_separate)
  112.             /* collect symbol table information for body (it is not a unit, 
  113.              * and must be saved explicitly here).
  114.              */
  115.             save_proper_body_info(unit_body);
  116.  
  117.         tup_frome(newtypes);
  118.  
  119.         if (N_KIND(unit_body) == as_insert) {
  120.             if (N_KIND(N_AST1(unit_body)) == as_subprogram_tr)
  121.                 /* for a subprogram instance, we place renaming code in the body
  122.                  * of the subprogram. If there is some additional instantiation 
  123.                  * code (bounds checks, etc.) it must be placed in a separate
  124.                  * unit on which the instantiation depends.
  125.                  */
  126.                 save_subprogram_instance_unit(node);
  127.             else
  128.                 /* Produce two units, one for spec instance and one for body. */
  129.                 save_package_instance_unit(node);
  130.         }
  131.         else {        /* any other kind of compilation unit.*/
  132.             save_comp_info(node);
  133.         }
  134.     }
  135.     /* Reinitialize compilation environment. */
  136.  
  137.     unit_name = strjoin("","");
  138.     newtypes = tup_with(newtypes, (char *) tup_new(0));
  139.     /*   DECLARED := BASE_DECLARED;
  140.      * Delete symbols placed in standard0 by previous compilation,
  141.      * restoring standard0 to its initial state. added_names is a tuple
  142.      * of identifiers added in prior compilation.
  143.      */
  144.     added_names = tup_new(0); /* build tuple of added identifiers */
  145.     FORDECLARED(id, sym, DECLARED(symbol_standard0), fd);
  146.         if (sym != (Symbol)0 && S_UNIT(sym))
  147.             added_names = tup_with(added_names, id);
  148.     ENDFORDECLARED(fd);
  149.     FORTUP(id=(char *), added_names, ft1);
  150.         dcl_undef(DECLARED(symbol_standard0), id);
  151.     ENDFORTUP(ft1);
  152.     tup_free(added_names);
  153.  
  154.     DECLARED(symbol_unmentionable) = base_declared[1];
  155.     DECLARED(symbol_standard) = base_declared[2];
  156.     DECLARED(symbol_ascii) = base_declared[3];
  157.     FORDECLARED(id, sym, DECLARED(symbol_ascii), fd);
  158.         IS_VISIBLE(fd) = TRUE;
  159.     ENDFORDECLARED(fd);
  160.     scope_name = symbol_standard0;
  161.     open_scopes = tup_new(2);
  162.     open_scopes[1] = (char *)symbol_standard0;
  163.     open_scopes[2] = (char *)symbol_unmentionable;
  164.     used_mods = tup_new(0);
  165.     vis_mods = tup_new1((char *) symbol_ascii);
  166.     scope_st = tup_new(0);
  167.     return;
  168. }
  169.  
  170. static void save_comp_info(Node node)                    /*;save_comp_info*/
  171. {
  172.     /* Subsidiary to the previous procedure. In the case of a unit which is
  173.      * a package instantiation, the current procedure is called twice, to
  174.      * produce separate units for the instance spec and the instance body.
  175.      */
  176.  
  177.     Unitdecl    ud;
  178.     char    *v;
  179.     Tuple    tup;
  180.     Set        vis_units;
  181.     int        uindex, i, si;
  182.     struct unit *pUnit;
  183.     Fortup    ft1;
  184.     Forset    fs1;
  185.     Stubenv    ev;
  186.     char    *stub_name;
  187.  
  188.     vis_units = set_new(tup_size(all_vis));
  189.  
  190.     uindex = unit_number(unit_name);
  191.     pUnit = pUnits[uindex];
  192.     /*PRE_COMP(unit_name) := vis_units;*/
  193.     FORTUP(v=(char *), all_vis, ft1);
  194.         vis_units = set_with(vis_units, (char *) unit_numbered(v));
  195.     ENDFORTUP(ft1);
  196.     pUnit->aisInfo.preComp = (char *)vis_units;
  197.     pUnit->aisInfo.pragmaElab = (char *) tup_copy(elab_pragmas);
  198.  
  199.     /* Before writing out any info, set unit of all symbols allocated
  200.      * while compiling this unit to current unit number
  201.      */
  202.     for (i = 1; i <= seq_symbol_n; i++)
  203.         S_UNIT((Symbol)seq_symbol[i]) = uindex;
  204.  
  205.     save_tree(node, uindex);
  206.     update_lib_maps(unit_name, 'u');
  207.     pUnit->aisInfo.compDate = (char *) tup_new(0);
  208.  
  209.     /*UNIT_DECL(unit_name) +:= [CONTEXT, UNIT_NODES];    */
  210.     ud = unit_decl_get(unit_name);
  211.     if (ud == (Unitdecl)0)
  212.         chaos("save_comp_info: unit decl missing");
  213.     ud->ud_context = tup_copy(context);
  214.     ud->ud_nodes = tup_copy(unit_nodes);
  215.     unit_decl_put(unit_name, ud);
  216.     if (!errors) {
  217.         /* Stub environment info is now written after the tree nodes
  218.          * are renumbered in save_tree. Also in case of erros Stub info
  219.          * is not written to st1 file.
  220.          */
  221.         FORSET(si=(int), stubs_to_write, fs1)
  222.             stub_name = lib_stub[si];
  223.             tup = (Tuple) stub_info[si];
  224.             ev = (Stubenv) tup[2];
  225.             write_stub(ev, stub_name, "st1");
  226.         ENDFORSET(fs1);
  227.     }
  228.     if (!errors) write_ais(uindex);
  229. }
  230.  
  231. static void new_unit_numbers(Node root, unsigned newUnitNumber)
  232.                                                         /*;new_unit_number*/
  233. {
  234.     unsigned nodeKind;
  235.     Node listNode;
  236.     Fortup ft1;
  237.     Tuple listTuple;
  238.  
  239.     if (root == (Node)0 || root == OPT_NODE) return;
  240.     N_UNIT(root) = newUnitNumber;
  241.  
  242.     nodeKind = N_KIND(root);
  243.     if (N_AST1_DEFINED(nodeKind)) new_unit_numbers(N_AST1(root), newUnitNumber);
  244.     if (N_AST2_DEFINED(nodeKind)) new_unit_numbers(N_AST2(root), newUnitNumber);
  245.     if (N_AST3_DEFINED(nodeKind)) new_unit_numbers(N_AST3(root), newUnitNumber);
  246.     if (N_AST4_DEFINED(nodeKind)) new_unit_numbers(N_AST4(root), newUnitNumber);
  247.  
  248.     if (! N_LIST_DEFINED(nodeKind)) return;
  249.  
  250.     listTuple = N_LIST(root);
  251.     FORTUP(listNode=(Node), listTuple, ft1);
  252.         new_unit_numbers(listNode, newUnitNumber);
  253.     ENDFORTUP(ft1);
  254. }
  255.  
  256. static void save_tree(Node root, int uindex)        /*;save_tree*/
  257. {
  258.     /* This procedure builds a sequential list of all the nodes in the
  259.      * abstract syntax tree while performing a preorder scan of the tree.
  260.      * For a given node, all its components are  placed in a flat tuple
  261.      * "tree_node".     This tuple is then added to the list.
  262.      *
  263.      * For the C version, we need to traverse the tree to find the reachable
  264.      * nodes, which are built up in a string reach such that reach[i] is
  265.      * 1 if node with sequence number i is reachable, 0 otherwise.
  266.      * We then call write_tree (lib.c)  to actually write the tree.
  267.      */
  268.  
  269.     int    stack_max, stack_now, na, i, unit_now, nk;
  270.     Tuple    stack, a;
  271.     Node    nodes[5], n, nod;
  272.     char    *reach;
  273. #define STACK_INC 50
  274.  
  275.     if (TREFILE == (IFILE *)0) return;
  276.     reach = emalloct((unsigned) ( seq_node_n+2) , "reach");
  277.     reach[seq_node_n+1] = '\0'; /* mark end of string */
  278.     for (i=0; i <= seq_node_n; i++) reach[i] = '0';
  279.     stack_max = tup_size(unit_nodes) + STACK_INC;
  280.     stack = tup_new(stack_max);
  281.     for (i = 1; i <= tup_size(unit_nodes); i++){
  282.         stack[i] = unit_nodes[i];
  283. #ifdef SAVE_TRACE
  284.         save_trace("init_stack", i, (Node) stack[i]);
  285. #endif
  286.     }
  287.     stack_now = tup_size(unit_nodes);
  288.     /* NOTE: must have STACK_INC > size of init_nodes.
  289.      * We do not write nodes for predefined entities in C version.
  290.      */
  291.     unit_now = N_UNIT(root);
  292.     stack_now++;
  293.     stack[stack_now] = (char *) root;
  294. #ifdef SAVE_TRACE
  295.     save_trace("init_root", stack_now, (Node) stack[stack_now]);
  296. #endif
  297.  
  298.     while (stack_now) {
  299.         /*n frome stack;*/
  300.         n = (Node) stack[stack_now];
  301. #ifdef DEBUG
  302.         if (trapns>0 && N_SEQ(n) == trapns && N_UNIT(n) == trapnu) trapn(n);
  303. #endif
  304.         /* define SAVE_TRACE for exhaustive trace as write tree */
  305. #ifdef SAVE_TRACE
  306.         save_trace("process", stack_now, (Node) n);
  307. #endif
  308.         if (N_UNIT(n) == unit_now)  reach[(int)N_SEQ(n)] = '1';
  309.         stack_now--;
  310.         if (n == OPT_NODE) continue;
  311.         /*tree_node := [n, N_KIND(n)];*/
  312.         nk = N_KIND(n);
  313.         nodes[1] = nodes[2] = nodes[3] = nodes[4] = (Node)0;
  314.         if (N_AST1_DEFINED(nk)) nodes[1] = N_AST1(n);
  315.         if (N_AST2_DEFINED(nk)) nodes[2] = N_AST2(n);
  316.         if (N_AST3_DEFINED(nk)) nodes[3] = N_AST3(n);
  317.         if (N_AST4_DEFINED(nk)) nodes[4] = N_AST4(n);
  318.         for (i = 1; i <= 4; i++) {
  319.             nod = nodes[i];
  320.             /*tree_node with:= #a;*/
  321.             if (nod == (Node)0) continue;
  322.             /*if (tree_node /=OPT_NODE) stack with:= a(#a-i+1);*/
  323.             if (nod == OPT_NODE) continue;
  324.             if (stack_now == stack_max) { /* expand stack */
  325.                 stack[0] = (char *) stack_now;
  326.                 stack = tup_exp(stack, (unsigned) (stack_now+STACK_INC));
  327.                 stack[0] = (char *) stack_now;
  328.                 stack_max += STACK_INC;
  329.             }
  330.             /* add node to stack */
  331.             /*tree_node with:= a(i);*/
  332.             stack[++stack_now] = (char *) nod;
  333. #ifdef SAVE_TRACE
  334.             save_trace("stack_ast", stack_now, nod);
  335. #endif
  336.         }
  337.         if (N_LIST_DEFINED(nk))
  338.             a = N_LIST(n);
  339.         else
  340.             a = (Tuple)0;
  341.         if (a != (Tuple)0 ) {
  342.             /*tree_node with:= #a;*/
  343.             na = tup_size(a);
  344.             /*(for i in [1..#a])*/
  345.             for (i = 1; i <= na; i++) {
  346.                 /*tree_node with:= a(i);*/
  347.                 nod = (Node) a[i]; 
  348.                 if (N_UNIT(nod) == unit_now) reach[(int)N_SEQ(nod)] = '1';
  349.                 /*stack with:= a(#a-i+1);*/
  350.                 if (stack_now == stack_max) {
  351.                     stack[0] = (char *) stack_now;
  352.                     stack = tup_exp(stack, (unsigned) stack_now+STACK_INC);
  353.                     stack[0] = (char *) stack_now;
  354.                     stack_max += STACK_INC;
  355.                 }
  356.                 stack[++stack_now] = (char *) nod;
  357. #ifdef SAVE_TRACE
  358.                 save_trace("stack_list", stack_now, nod);
  359. #endif
  360.             }
  361.         }
  362.     }
  363.     renumber_nodes(reach);
  364.     write_tre(uindex, N_SEQ(root), reach);
  365.     efreet(reach, "reach");
  366.     tup_free(stack);
  367. }
  368.  
  369. static void renumber_nodes(char *reach)            /*;renumber_nodes*/
  370. {
  371.     /* This procedure renumbers the nodes so that the nodes which are live
  372.      * (not dead) and need to be written out in the tree (trc) file are 
  373.      * contigous and the seq_node array is therefore dense. This reduces 
  374.      * the size of seq_node necessary for separate compilation and in the 
  375.      * code generator phase. In addition the offset table written in the trc 
  376.      * file will also be reduced with this compressed version. The scheme 
  377.      * is relatively simple in that all nodes that are unreachable are 
  378.      * exchanged with positions that are reachable which appear later in 
  379.      * the list (tuple). Only one pass over the nodes is necessary using this
  380.      * method, so it is quite efficient.  
  381.      * Note that seq_node_n is changed in this procedure.
  382.      */
  383.  
  384.     int     i, j;
  385.     int        reachable_node_found;
  386.     Node    nod, unreachable_node;
  387.  
  388.     j = seq_node_n;
  389.     for (i = 1; i <= j; i++) {
  390.         /* First search rightward for a node which is unreachable (where reach 
  391.          * is 0 for that element). This will then be exchanged with a node 
  392.          * which is reachable which is found by searching the list leftward.
  393.          * Ultimately the left and right pointers (i & j) will converge.
  394.          */
  395.         if (reach[i] == '1') continue;
  396.         reachable_node_found = 0;
  397.  
  398.         /* Search for reachable node from the right */
  399.         for (; j > i; j--) {
  400.             if (reach[j] == '1') {
  401.                 reachable_node_found = 1;
  402.                 break;
  403.             }
  404.         }
  405.         /* If there is no reachable node found any more we are done with the
  406.          * compression.
  407.          */
  408.         if (!reachable_node_found)  break;
  409.         nod = (Node) seq_node[j];
  410.         unreachable_node = (Node) seq_node[i];
  411.         /* Exchange positions of the two nodes and set their seqeunce number 
  412.          * to the respective new position numbers.
  413.          * Currently the node in seq_node[i] cannot be wiped out since it is
  414.          * still needed because of save_package_instance.
  415.          */
  416.         seq_node[i] = (char *) nod;
  417.         seq_node[j] = (char *) unreachable_node;
  418.         N_SEQ(nod) = i;
  419.         N_SEQ(unreachable_node) = j;
  420.         reach[i] = '1';
  421.         reach[j] = '0';
  422.     }
  423.     seq_node_n = i - 1;
  424. }
  425.  
  426. #ifdef SAVE_TRACE
  427. void save_trace(char *s, int n, Node nod)
  428. {
  429.     if (save_trace_opt == 0) return;
  430.     printf("%11s %d\n", s, n);
  431.     zpnod(nod);
  432. }
  433. #endif
  434. void save_trace_init()
  435. {
  436.     save_trace_opt++;
  437. }
  438.  
  439. Tuple unit_symbtab(Symbol unit_unam, char unit_typ)            /*;unit_symbtab*/
  440. {
  441.     /* Collect symbol table entries for all entities declared in a compila-
  442.      * tion     unit, including inner units  and blocks. We iterate  over  the
  443.      * symbol table, and save all objects that are declared in the unit and
  444.      * in inner scopes.  For non-generic package bodies, we omit the  decla-
  445.      * rations that     appear in the visible part, and are already saved with 
  446.      * the package spec.
  447.      */
  448.  
  449.     Tuple    symb_map;
  450.     Tuple    ignore;
  451.     Set        scopes, seen;
  452.     Symbol    u_name, sc, sym;
  453.     char    *id;
  454.     Fordeclared fd1;
  455.     Forprivate_decls fp1;
  456.     Private_declarations pd;
  457.     int        ignore_n;
  458.  
  459.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : unit_symbtab:");
  460.  
  461.     unit_nodes = tup_new(0);
  462.     if (errors) return unit_nodes;
  463.  
  464.     symb_map = tup_new(0);
  465.     ignore = tup_new(0); 
  466.     ignore_n = 0;
  467.     if (NATURE(unit_unam) == na_package && unit_typ == 'u') {
  468.         ignore = tup_exp(ignore, 10);
  469.         ignore_n = 0;
  470.         FORDECLARED(id, u_name, DECLARED(unit_unam), fd1);
  471.             if (IS_VISIBLE(fd1)) {
  472.                 if (tup_mem((char *) u_name, ignore)) continue;
  473.                 if (ignore_n>=tup_size(ignore)) {
  474.                     ignore = tup_exp(ignore, (unsigned) (ignore_n+10));
  475.                 }
  476.                 ignore_n += 1;
  477.                 ignore[ignore_n] = (char *) u_name;
  478.             }
  479.         ENDFORDECLARED(fd1);
  480.     }
  481.  
  482.     /* first, collect the nodes referenced in the current unit Symbtab record.
  483.      * then, iterate through it's declared map to get declarations in inner
  484.      * scopes.
  485.      */
  486.     collect_unit_nodes(unit_unam);
  487.  
  488.     ignore[0] = (char *) ignore_n;
  489.     seen = set_new1((char *) unit_unam);
  490.     scopes = set_copy(seen);
  491.  
  492.     while (set_size(scopes) != 0) {
  493.         sc = (Symbol) set_from(scopes);
  494.         FORDECLARED(id, u_name, DECLARED(sc), fd1);
  495.             if (! tup_mem((char *)u_name, ignore) ) {    /* save its info. */
  496.                 /* Collect the AST nodes that appear in SYMBTAB, and may thus*/
  497.                 /* be needed for separate compilation and code generation.*/
  498.                 collect_unit_nodes(u_name);
  499.                 /*symb_map(u_name) := SYMBTABF(u_name);*/
  500.                 symb_map = sym_save(symb_map, u_name, unit_typ);
  501.             }
  502.             /* note that na_enum symbols have their literal map stored in the
  503.              * DECLARED field and so should be skipped in next test
  504.              * IS THIS STILL TRUE???? 
  505.              */
  506.             if (NATURE(u_name) == na_enum) continue;
  507.  
  508.             if (DECLARED(u_name) != (Declaredmap)0 
  509.               && (!set_mem((char *)u_name, seen ) )){
  510.                 /* collect local declarations of inner scope.*/
  511.                 scopes = set_with(scopes, (char *) u_name);
  512.                 seen = set_with(seen, (char *) u_name);
  513.             }
  514.         ENDFORDECLARED(fd1);
  515.  
  516.         if (NATURE(sc) == na_package || NATURE(sc) == na_package_spec
  517.           || NATURE(sc) == na_generic_package
  518.           || NATURE(sc) == na_generic_package_spec) {
  519.             /* Collect and save nodes attatched to private_decls field */
  520.             pd = (Private_declarations) private_decls(sc);
  521.             FORPRIVATE_DECLS(sym, u_name, pd, fp1);
  522.                 collect_unit_nodes(u_name);
  523.             ENDFORPRIVATE_DECLS(fp1);
  524.         }
  525.     }
  526.     /* We include in symb_map the information for the unit itself, which is
  527.      * declared in STANDARD.
  528.      */
  529.     /* TBSL: get rid of this KLUDGE
  530.      * for generic subprograms, save symbol regardless of unit, so that the
  531.      * unit name of body is retrievable after being overwritten by spec
  532.      */
  533.     if (NATURE(unit_unam) == na_generic_procedure
  534.       || NATURE(unit_unam) == na_generic_function 
  535.       || NATURE(unit_unam) == na_generic_package)
  536.         symb_map = sym_save(symb_map, unit_unam, 's');
  537.     else 
  538.         symb_map = sym_save(symb_map, unit_unam, unit_typ);
  539.     set_free(seen); 
  540.     set_free(scopes);
  541.     /* replace symbol pointers to copy of symbol table entries */
  542.     tup_free(ignore);
  543.     return symb_map;
  544. }
  545.  
  546. static void collect_unit_nodes(Symbol u_name)            /*;collect_unit_nodes*/
  547. {
  548.     /* Collect the AST nodes that appear in SYMBTAB, and may thus*/
  549.     /* be needed for separate compilation and code generation.*/
  550.  
  551.     int     nat, i, size;
  552.     Symbol     typ;
  553.     Tuple    sig, discr_map, gen_list, tup;
  554.     Fortup     ft1;
  555.  
  556.     typ = TYPE_OF(u_name);
  557.     nat = NATURE(u_name);
  558.     if (typ == symbol_incomplete || typ == symbol_private 
  559.       || typ == symbol_limited_private)
  560.         nat = na_record; /* signature has form of record signature */
  561.  
  562.     switch (nat) {
  563.     case na_constant:
  564.     case na_discriminant:
  565.     case na_in:
  566.         unit_nodes_add((Node) default_expr(u_name));
  567.         break;
  568.     case na_type:
  569.         sig = SIGNATURE(u_name);
  570.         if (sig == (Tuple)0)
  571.             chaos("unit_symbtab subtype - no signature");
  572.         if ((int) sig[1] == CONSTRAINT_DELTA) {
  573.             unit_nodes_add((Node) numeric_constraint_low(sig));
  574.             unit_nodes_add((Node) numeric_constraint_high(sig));
  575.             unit_nodes_add((Node) numeric_constraint_delta(sig));
  576.             unit_nodes_add((Node) numeric_constraint_small(sig));
  577.         }
  578.         break;
  579.     case na_subtype:
  580.         sig = SIGNATURE(u_name);
  581.         if (sig == (Tuple)0)
  582.             chaos("unit_symbtab subtype - no signature");
  583.         if (is_scalar_type(u_name))     {
  584.             unit_nodes_add((Node) numeric_constraint_low(sig));
  585.             unit_nodes_add((Node) numeric_constraint_high(sig));
  586.             if ((int) sig[1] == CONSTRAINT_DELTA) {
  587.                 unit_nodes_add( (Node) numeric_constraint_delta(sig));
  588.                 unit_nodes_add( (Node) numeric_constraint_small(sig));
  589.             }
  590.             else if ((int) sig[1] == CONSTRAINT_DIGITS) {
  591.                 unit_nodes_add( (Node) numeric_constraint_digits(sig));
  592.             }
  593.         }
  594.         else if (is_record(u_name)) {
  595.             discr_map = (Tuple) sig[2];
  596.             size = tup_size(discr_map);
  597.             for (i = 1; i <= size; i+=2)
  598.                 unit_nodes_add((Node) discr_map[i+1]);
  599.         }
  600.         break;
  601.     case na_enum:
  602.         sig = SIGNATURE(u_name);
  603.         if (sig == (Tuple)0) chaos("unit_symbtab enum - no signature");
  604.         unit_nodes_add((Node) numeric_constraint_low(sig));
  605.         unit_nodes_add((Node) numeric_constraint_high(sig));
  606.         break;
  607.     case na_record:
  608.         unit_nodes_add((Node) invariant_part(u_name));
  609.         unit_nodes_add((Node) variant_part(u_name));
  610.         unit_nodes_add((Node) discr_decl_tree(u_name));
  611.         break;
  612.     case na_procedure_spec:
  613.     case na_function_spec:
  614.     case na_entry:
  615.     case na_entry_family:
  616.     case na_generic_procedure_spec:
  617.     case na_generic_function_spec:
  618.         unit_nodes_add((Node) formal_decl_tree(u_name));
  619.         break;
  620.         /* 
  621.          * Clear out the formal_decl_tree fields of procedure or 
  622.          * function symbols since these are not needed for 
  623.          * conformance checks (only na_procedure_spec or 
  624.          * na_function_spec symbols need this entry).
  625.          */
  626.     case na_procedure:
  627.     case na_function:
  628.         formal_decl_tree(u_name) = (Symbol)0;
  629.         break;
  630.         /*
  631.          * the nodes of generic packages(specs and bodies) or nodes of generic
  632.          * subprograms bodies are not automatically read in. They are brought 
  633.          * in explicitly upon instantiation. Default values for generic para-
  634.          * meters however must be read in for instantiation. The generic_list
  635.          * is a tuple of pairs [name, initial value] which we unpack here.
  636.          */
  637.     case na_generic_package_spec:
  638.     case na_generic_package:
  639.     case na_generic_function:
  640.     case na_generic_procedure:
  641.         sig = SIGNATURE(u_name);
  642.         gen_list = (Tuple)sig[1];
  643.         FORTUP(tup=(Tuple), gen_list, ft1)
  644.             unit_nodes_add((Node)tup[2]);
  645.         ENDFORTUP(ft1);
  646.         break;
  647.     }
  648. }
  649.  
  650. void save_subprog_info(Symbol unit_unam)                /*;save_subprog_info*/
  651. {
  652.     /* Save declarations for a subprogram specification or body which is a
  653.      * compilation unit.
  654.      */
  655.  
  656.     int    uindex;
  657.     Unitdecl ud;
  658.  
  659.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  save_subprog_info");
  660.  
  661.     if (IS_COMP_UNIT){
  662.         if (unit_unam == (Symbol)0) {
  663.             errmsg("Invalid compilation unit", "none", (Node)0);
  664.             return;
  665.         }
  666.         /* get unit number (assign new one if needed) */
  667.         uindex = unit_number(unit_name);
  668.  
  669.         /* For subprograms, UNIT_DECL has 4 fields:
  670.          *    1.  unique name of subprogram
  671.          *    2.  symbol table entries
  672.          *    3.  declared maps for subprogram's scope
  673.          *      ( for possible late instantiations)
  674.          *    4.  context (supplied in compunit)
  675.          *
  676.          * case nature(unit_unam) of
  677.          *  (na_procedure_spec, na_function_spec,
  678.          *  na_generic_procedure_spec, na_generic_function_spec):
  679.          *   decmap := {[unit_unam, declared(unit_unam)]};
  680.          *
  681.          *  TBSL for generics
  682.          *  (na_generic_procedure, na_generic_function):
  683.          *  decmap := generic_declarations();
  684.          *  decmap(unit_unam) := declared(unit_unam);
  685.          *
  686.          * else
  687.          *  TBSL for generics
  688.          *  decmap := generic_declarations();
  689.          * end case;
  690.          *
  691.          * UNIT_DECL(unit_name) :=
  692.          *   [unit_unam, unit_symbtab(unit_unam), decmap, [], {}];
  693.          */
  694.         ud = unit_decl_get(unit_name);
  695.         if (ud == (Unitdecl)0) ud = unit_decl_new();
  696.         ud->ud_unam = unit_unam;
  697.         ud->ud_useq =  S_SEQ(unit_unam);
  698.         ud->ud_unit =  S_UNIT(unit_unam);
  699.         ud->ud_symbols = unit_symbtab(unit_unam, 'u');
  700.         if (DECLARED(unit_unam) == (Declaredmap)0) {
  701.             ud->ud_decscopes = (Tuple) 0;
  702.             ud->ud_decmaps     = (Tuple) 0;
  703.         }
  704.         else {
  705.             ud->ud_decscopes = tup_new1((char *) unit_unam);
  706.             ud->ud_decmaps = tup_new1(
  707.               (char *) dcl_copy(DECLARED(unit_unam)));
  708.         }
  709.         unit_decl_put(unit_name, ud);
  710.     }
  711. }
  712.  
  713. static void generic_declarations(Symbol unit_unam, Unitdecl ud)
  714.                                                     /*;generic_declarations*/
  715. {
  716.     /* This procedure collects the contents of declared maps within generic
  717.      *  subunits, for possible subsequent late instantiations.
  718.      */
  719.  
  720.     Tuple    decscopes, decmaps;
  721.     Set    decl_scopes, scopes, seen;
  722.     Symbol u_name, sc;
  723.     char    *id;
  724.     Fordeclared fd1;
  725.     decscopes = tup_new(0);
  726.     decmaps = tup_new(0);
  727.  
  728.     if (NATURE(unit_unam) == na_generic_package)
  729.         decl_scopes = tup_new1((char *) unit_unam);
  730.     else
  731.         decl_scopes = tup_new(0);
  732.  
  733.     /* In SETL want to iterate over declared - i.e., we need to  know domain
  734.      * of declared. We take this by looking at all symbols defined in current
  735.      * unit for which declared field defined. This includes some extra symbols,
  736.      * I think due to private decls, but these extra maps seem harmless.
  737.      */
  738.     scopes = set_new1((char *)unit_unam);
  739.     seen = set_new(0);
  740.     while (set_size(scopes) != 0) {
  741.         sc = (Symbol) set_from(scopes);
  742.         seen = set_with(seen, (char *)sc);
  743.         if (DECLARED(sc) != (Declaredmap)0) {
  744.             FORDECLARED(id, u_name, DECLARED(sc), fd1);
  745.             if (DECLARED(u_name) != (Declaredmap)0 
  746.               &&(!set_mem((char *)u_name, seen))) {
  747.                 /* collect local declarations of inner scope.*/
  748.                 if (NATURE(u_name) == na_generic_procedure
  749.                   || NATURE(u_name) == na_generic_function
  750.                   || NATURE(u_name) == na_generic_package)
  751.                     decl_scopes = set_with(decl_scopes, (char *)u_name);
  752.                 else if (NATURE(u_name) == na_package)
  753.                     scopes = set_with(scopes, (char *) u_name);
  754.             }
  755.             ENDFORDECLARED(fd1);
  756.         }
  757.     }
  758.  
  759.     seen = set_new(0);
  760.  
  761.     while (set_size(decl_scopes) != 0) {
  762.         sc = (Symbol) set_from(decl_scopes);
  763.         seen = set_with(seen, (char *)sc);
  764.         decscopes = tup_with(decscopes, (char *) sc);
  765.         decmaps = tup_with(decmaps, (char *) dcl_copy(DECLARED(sc)));
  766.         FORDECLARED(id, u_name, DECLARED(sc), fd1);
  767.             if (DECLARED(u_name) != (Declaredmap)0 
  768.               &&(!set_mem((char *)u_name, seen)))
  769.                 /* collect local declarations of inner scope.*/
  770.                 decl_scopes = set_with(decl_scopes, (char *) u_name);
  771.         ENDFORDECLARED(fd1);
  772.     }
  773.  
  774.     ud->ud_decscopes = decscopes;
  775.     ud->ud_decmaps = decmaps;
  776.     set_free(seen); 
  777.     set_free(scopes);
  778. }
  779.  
  780. void save_spec_info(Symbol unit_unam, Tuple old_vis)        /*;save_spec_info*/
  781. {
  782.     /* Build UNIT_DECL for a package spec. that is a compilation unit.*/
  783.  
  784.     Symbol    sn;
  785.     int    i, uindex;
  786.     Tuple    decscopes, decmaps, decl_scopes;
  787.     Unitdecl ud;
  788.  
  789.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : save_spec_info");
  790.  
  791.     /* This was here as early as 1983, and now not only seems useless, but
  792.      * is WRONG !!!
  793.      * At end of module_body, we iterate over all inner scopes, and the presence
  794.      * of generic inside scope of instance results in looping.
  795.     if (NATURE(unit_unam) == na_generic_package_spec) {
  796.      * save name within its own declarations, to simplify retrieval at
  797.      * instantiation time.
  798.         dcl_put(DECLARED(unit_unam), original_name(unit_unam), unit_unam);
  799.     }
  800.      */
  801.     /*
  802.      * For package specifications, UNIT_DECL has 6 fields.
  803.      *    1. unique name of compilation unit
  804.      *    2. symbol table entries
  805.      *    3. declared maps for program defined scopes
  806.      *    4. vis_mods
  807.      *    5. difference between declared and visible
  808.      *    6. context (supplied in comp_unit)
  809.      */
  810.     decscopes = tup_new(0);
  811.     decmaps = tup_new(0);
  812.     /* In SETL want to iterate over declared - i.e., we need to  know domain
  813.      * of declared. We take this by looking at all symbols defined in current
  814.      * unit for which declared field defined. This includes some extra symbols,
  815.      * I think due to private decls, but these extra maps seem harmless.
  816.      */
  817.     decl_scopes = tup_new(0);
  818.     for (i = 1; i <= seq_symbol_n; i++)
  819.         if (DECLARED((Symbol)seq_symbol[i]) != (Declaredmap)0)
  820.             decl_scopes = tup_with(decl_scopes, seq_symbol[i]);
  821.     for (i = 1; i <= tup_size(decl_scopes); i++){
  822.         sn = (Symbol) decl_scopes[i];
  823.         decscopes = tup_with(decscopes, (char *) sn);
  824.         decmaps = tup_with(decmaps, (char *) dcl_copy(DECLARED(sn)));
  825.     }
  826.     /*decmap := {[sn, dsn] : dsn = declared(sn) | sn notin p_s};
  827.      *
  828.      * Notvis keeps track of things declared but not visible
  829.      */
  830. #ifdef TBSL
  831. -- note change in def of notvis 5-jan-85:
  832.     only define notvis
  833.         -- is vis is not om.
  834. notvis :
  835.         = {
  836.     };
  837.     (for [sn, dsn] in decmap | visible(sn) /= om)
  838.         notvis(sn) :
  839.         = {
  840. dec: 
  841.             dec in dsn | dec notin visible(sn)        };
  842.     end for;
  843.     notvis = tup_new(0);
  844. #endif
  845.     /* UNIT_DECL(unit_name) :=
  846.      *   [unit_unam, unit_symbtab(unit_unam), decmap, old_vis, notvis];
  847.      * In C version have different format .
  848.      */
  849.  
  850.     if (!unit_numbered(unit_name)) uindex = unit_number(unit_name);
  851.     ud = unit_decl_get(unit_name);
  852.     if (ud == (Unitdecl)0) ud = unit_decl_new();
  853.     ud->ud_unam =    unit_unam;
  854.     ud->ud_useq = S_SEQ(unit_unam);
  855.     ud->ud_unit = S_UNIT(unit_unam);
  856.     ud->ud_symbols = unit_symbtab(unit_unam, 'u');
  857.     ud->ud_decscopes = decscopes;
  858.     ud->ud_oldvis = tup_copy(old_vis);
  859.     ud->ud_decmaps = decmaps;
  860.     unit_decl_put(unit_name, ud);
  861. }
  862.  
  863. void save_body_info(Symbol nam)                    /*;save_body_info*/
  864. {
  865.     /* For a package body, only the symbol table information needs to be
  866.      * saved, for purposes of generic instantiation. Visibility information
  867.      * is not kept.
  868.      */
  869.  
  870.     int        uindex;
  871.     Unitdecl    ud;
  872.  
  873.     if (cdebug2 > 3) TO_ERRFILE("AT PROC: save_body_info");
  874.  
  875.     if (IS_COMP_UNIT) {
  876.         /*
  877.          * UNIT_DECL(unit_name) := [nam, unit_symbtab(nam), 
  878.          *                generic_declarations(), [], {}];
  879.          */
  880.         uindex = unit_number(unit_name);
  881.         ud = unit_decl_get(unit_name);
  882.         if (ud == (Unitdecl)0) ud = unit_decl_new();
  883.         ud->ud_unam =  nam;
  884.         ud->ud_useq =  S_SEQ(nam);
  885.         ud->ud_unit =  S_UNIT(nam);
  886.         ud->ud_symbols  =  unit_symbtab(nam, 'u');
  887.         generic_declarations(nam, ud);
  888.         unit_decl_put(unit_name, ud);
  889.     }
  890. }
  891.  
  892. static void save_proper_body_info(Node node)        /*;save_proper_body_info*/
  893. {
  894.     Node    proper_node, spec, name_node;
  895.     Symbol    unit_unam;
  896.     Unitdecl    ud;
  897.  
  898.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  save_proper_body_info");
  899.  
  900.     proper_node = N_AST2(node);
  901.     if (N_KIND(proper_node) == as_generic_procedure
  902.       || N_KIND(proper_node) == as_generic_function) {
  903.         spec = N_AST1(proper_node);
  904.         name_node = N_AST1(spec);
  905.     }
  906.     /* For subprogram proper bodies the unique name is stored in the
  907.      * proper_node itself.
  908.      */
  909.     else if (N_KIND(proper_node) == as_subprogram_tr) {
  910.         name_node = proper_node;
  911.     }
  912.     else 
  913.         name_node = N_AST1(proper_node);
  914.  
  915.     unit_unam = N_UNQ(name_node);
  916.  
  917.     /* UNIT_DECL(unit_name) :=
  918.      *    [unit_unam, unit_symbtab(unit_unam), generic_declarations(), [], {}];
  919.      */
  920.  
  921.     ud = unit_decl_get(unit_name);
  922.     if (ud == (Unitdecl)0) ud = unit_decl_new();
  923.     ud->ud_unam = unit_unam;
  924.     ud->ud_useq = S_SEQ(unit_unam);
  925.     ud->ud_unit = S_UNIT(unit_unam);
  926.     ud->ud_symbols = unit_symbtab(unit_unam, 'u');
  927.  
  928. #ifdef TBSL
  929.     handle generic_declarations
  930. #endif
  931.  
  932.     unit_decl_put(unit_name, ud);
  933. }
  934.  
  935. static void save_package_instance_unit(Node node)/*;save_package_instance_unit*/
  936. {
  937.     /* If a unit is a package instance, it is necessary to construct two 
  938.      * units, one for the spec and one for the body of the instance.
  939.      */
  940.  
  941.     Node    context_node, unit_body, spec_node, body_node, id_node, b_node;
  942.     char    *nam;
  943.     Symbol    unam;
  944.     Tuple    tup;
  945.     Unitdecl    ud;
  946.     int        saved_seq_node_n, i;
  947.  
  948.     context_node = N_AST1(node);
  949.     unit_body = N_AST2(node);
  950.  
  951.     /* The unit body is an insert node; unpack spec and body of instance.*/
  952.     tup = N_LIST(unit_body);
  953.     spec_node = (Node) tup[1];
  954.     id_node = N_AST1(spec_node);
  955.     body_node = N_AST1( unit_body);
  956.  
  957.     N_AST1(node) = context_node;
  958.     N_AST2(node) = spec_node;
  959.     unit_name[0] = 's'; /* set to spec */
  960.     unit_name[1] = 'p';
  961.  
  962.     /* Build a node for the package instance, and rebuild compilation info.
  963.      * for it. Its UNIT_DECL need not contain symbol table info, which is
  964.      * emitted with the spec, and always retrieved at the same time.
  965.      * TBSL: what if this is a delayed instance?
  966.      */
  967.     nam = unit_name_name(unit_name);
  968.     b_node = node_new(as_unit);
  969.     N_AST1(b_node) = context_node;
  970.     N_AST2(b_node) = body_node;
  971.  
  972.     /* Since nodes for the spec and body were created at the same time they
  973.      * both have the same unit number. 
  974.      * After the spec is written change the unit field of all the body nodes 
  975.      * to reflect its unit.
  976.      */
  977.     unam = N_UNQ(id_node);
  978.     /* Set the nature of the symbol to be as a package spec so that the private 
  979.      * declarations (OVERLOADS field) is set upon reading the spec of the 
  980.      * instantiated package. Reset to package after the unit is written.
  981.      */
  982.     NATURE(unam) = na_package_spec;
  983.     /* Save the old value of seq_node_n since this will be changed when
  984.      * renumber_nodes is called by save_tree and sets seq_node_n to the 
  985.      * number of live and useful nodes. However all the nodes in seq_node need
  986.      * to be accessable for working with the package body nodes, so we will
  987.      * have to reset seq_node_n to the saved value. This is basically due to
  988.      * the artifact of how instantiated package body are handled.
  989.      */
  990.     saved_seq_node_n = seq_node_n;
  991.     save_comp_info(node);
  992.     seq_node_n = saved_seq_node_n;
  993.     OVERLOADS(unam) = 0;
  994.     NATURE(unam) = na_package;
  995.  
  996.     all_vis = tup_with(all_vis, unit_name);        /* body depends on spec.*/
  997.     unit_name = strjoin("bo", nam);
  998.     unit_number_now = unit_number(unit_name);
  999.     new_unit_numbers(b_node, unit_number_now);
  1000.     /* Set the number of symbols to be 0 so that the unit number of the symbol
  1001.      * for the package is not reset to be the unit number for the body.
  1002.      */
  1003.     seq_symbol_n = 0;
  1004.     unit_nodes = tup_new(0);
  1005.     unam = N_UNQ(id_node);
  1006.     ud = unit_decl_new();
  1007.     ud->ud_unam = unam;
  1008.     ud->ud_useq = S_SEQ(unam);
  1009.     ud->ud_unit = S_UNIT(unam);
  1010.     ud->ud_symbols = tup_new(0);
  1011.     unit_decl_put(unit_name, ud);
  1012.  
  1013.     /*UNIT_DECL(unit_name) := [nam, {}, {}, [], {}];*/
  1014.     /* TBSL: note that now setting five components    ds 7 dec 84 */
  1015.  
  1016.     save_comp_info(b_node);
  1017. }
  1018.  
  1019. static void save_subprogram_instance_unit(Node node)
  1020.   /*; save_subprogram_instance_unit */
  1021. {
  1022.     /* The instantiation code (renamings of formals by actuals, bounds checks)
  1023.      * are elaborated before the body of the instance. If the instance is a
  1024.      * unit, the instantiation code must in fact be placed in a anonymous unit
  1025.      * on which the instantiation depends.
  1026.      * For now, we place the renamings in the dclarative part of the procedure,
  1027.      * which is inefficient but harmless. 
  1028.      * TBSL: construction of anonymous unit with the rest
  1029.      */
  1030.  
  1031.     Tuple  i_code , i_decls, i_checks, ntup;
  1032.     Node   instance, decl_node, n, ins_node, context_node, b_node;
  1033.     int    i, k;
  1034.  
  1035.     context_node = N_AST1(node);
  1036.     ins_node = N_AST2(node);            /* insert node */
  1037.     i_code = N_LIST(ins_node);            /* instantiation code */
  1038.     instance = N_AST1(ins_node);        /* subprogram instance*/
  1039.     N_AST2(node) = instance;
  1040.     decl_node = N_AST2(instance);
  1041.     i_decls = tup_new(0);
  1042.     i_checks = tup_new(0);
  1043.     for ( i = 1; i <= tup_size(i_code); i++) {
  1044.         n = (Node)tup_fromb(i_code);
  1045.         k = N_KIND(n);
  1046.         if (k == as_raise || k == as_check_bounds || k == as_check_discr)
  1047.             i_checks = tup_with(i_checks, (char *) n);
  1048.         else
  1049.             i_decls  = tup_with(i_decls, (char *) n);
  1050.     }
  1051.  
  1052.     ntup = tup_add(i_decls, N_LIST(decl_node));
  1053.     tup_free(N_LIST(decl_node));
  1054.     N_LIST(decl_node) = ntup;
  1055.  
  1056.     b_node = node_new(as_unit);
  1057.     N_AST1(b_node) = context_node;
  1058.     N_AST2(b_node) = instance;
  1059.     save_comp_info(b_node);
  1060.  
  1061.     if (tup_size(i_checks) > 0) 
  1062.         chaos("subprogram_instance_unit: checks left over");
  1063. }
  1064.  
  1065. static void establish_context(Node node)    /*;establish_context*/
  1066. {
  1067.     char    *name, *nam;
  1068.     Fortup    ft1, ft2, ft3;
  1069.     Node    un_node, clause_node, uw_node, unit_node;
  1070.     Node    context_node, spec, name_node;
  1071.     int    kind, i, nk;
  1072.     Tuple    tupn, tup, use_nodes, with_tup;
  1073.     char    *spec_name;
  1074.     Tuple    elaborate_list, with_list, nam_list, inherited_context = (Tuple)0;
  1075.     Unitdecl spec_decl;
  1076.  
  1077.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  establish_context(name);");
  1078.  
  1079.     context_node = N_AST1(node);
  1080.     unit_node = N_AST2(node);
  1081.  
  1082.     /* Flatten with- and use-clauses from context node.*/
  1083.  
  1084.     context = tup_new(0);
  1085.     with_list = N_LIST(context_node);
  1086.     elaborate_list = tup_new(0);
  1087.     /* NOTE that ELABORATE pragmas can only appear immediately after a
  1088.      * context_clause.  The necessary checks to insure that this condition
  1089.      * is met have not been made.
  1090.      */
  1091.     use_nodes = tup_new(0);
  1092.     with_tup = tup_new(0);
  1093.     FORTUP(clause_node=(Node), with_list, ft1);
  1094.         FORTUP(uw_node=(Node), N_LIST(clause_node), ft2);
  1095.             kind = N_KIND(uw_node);
  1096.             if (kind == as_with || kind == as_use) {
  1097.                 tupn = tup_new(tup_size(N_LIST(uw_node)));
  1098.                 FORTUPI(un_node=(Node), N_LIST(uw_node), i, ft3);
  1099.                     tupn[i] = N_VAL(un_node);
  1100.                 ENDFORTUP(ft3);
  1101.                 tup = tup_new(2);
  1102.                 tup[1] = (char *) kind;
  1103.                 tup[2] = (char *) tupn;
  1104.                 context = tup_with(context, (char *) tup);
  1105.                 if (kind == as_use) {
  1106.                     /* save nodes for subsequent call to resolve_use_clause */
  1107.                     use_nodes = tup_with(use_nodes, (char *)uw_node);
  1108.                     /* check that it appears in a previous with clause */
  1109.                     FORTUP(name = (char *), tupn, ft3);
  1110.                         if (!tup_memstr(name, with_tup))
  1111.                         errmsg_str("% does not appear in previous with clause",
  1112.                           name, "10.1.1", uw_node);
  1113.                     ENDFORTUP(ft3);
  1114.                 }
  1115.                 else {
  1116.                     with_tup = tup_add(with_tup, tupn);
  1117.                 }
  1118.             }
  1119.             else {
  1120.                 elaborate_list = tup_with(elaborate_list, (char *) uw_node);
  1121.             }
  1122.         ENDFORTUP(ft2);
  1123.     ENDFORTUP(ft1);
  1124.  
  1125.     /* For bodies and proper bodies, collect any context specification
  1126.      * inherited from parent unit or from spec.
  1127.      */
  1128.     nk = N_KIND(unit_node);
  1129.     if (nk == as_separate) {
  1130.         inherited_context = check_separate(unit_node);
  1131.         if (inherited_context == (Tuple)0) {
  1132.             context = (Tuple) 0; /* indicates error */
  1133.             return;
  1134.         }
  1135.     }
  1136.     else if (nk == as_package_body) {
  1137.         name_node = N_AST1(unit_node);
  1138.         name = N_VAL(name_node);
  1139.         current_node = name_node;
  1140.         get_specs(name);
  1141.         all_vis = tup_with(all_vis, strjoin("sp", name));
  1142.         /* all_vis with:= ['spec', name]; */
  1143.         spec_decl = unit_decl_get(strjoin("sp", name));
  1144.         if (spec_decl != (Unitdecl)0)
  1145.             inherited_context = spec_decl->ud_context;
  1146.     }
  1147.     else if (nk == as_subprogram) {
  1148.         /* may have been subprogram spec.*/
  1149.         spec = N_AST1(unit_node);
  1150.         name_node = N_AST1(spec);
  1151.         name = N_VAL(name_node);
  1152.         spec_name = strjoin("ss", name);
  1153.         if (retrieve(spec_name) )
  1154.             all_vis = tup_with(all_vis, spec_name);
  1155.  
  1156.         spec_decl  = unit_decl_get(spec_name);
  1157.         if (spec_decl != (Unitdecl)0)
  1158.             inherited_context =  spec_decl->ud_context;
  1159.     }
  1160.  
  1161.     if (inherited_context == (Tuple) 0)
  1162.         /* this may occur if there were errors in previous units */
  1163.         inherited_context = tup_new(0);
  1164.  
  1165.     /* process inherited context specification */
  1166.     FORTUP(tup=(Tuple), inherited_context, ft1);
  1167.         kind = (int) tup[1];
  1168.         nam_list = (Tuple) tup[2];
  1169.  
  1170.         if (kind == as_with)
  1171.             with_clause(nam_list, current_node);
  1172.         else if (kind == as_use) {
  1173.             /* rebuild list of name nodes for use_clause */
  1174.             un_node = node_new(as_use);
  1175.             N_LIST(un_node) = tup_new(tup_size(nam_list));
  1176.             FORTUPI(nam = (char *), nam_list, i, ft2);
  1177.                 name_node = node_new(as_simple_name);
  1178.                 N_VAL(name_node) = nam;
  1179.                 N_LIST(un_node)[i] = (char *)name_node;
  1180.             ENDFORTUP(ft2);
  1181.             use_clause(un_node);
  1182.         }
  1183.     ENDFORTUP(ft1);
  1184.  
  1185.     /* Process the given context specification. */
  1186.     FORTUP(tup=(Tuple), context, ft1);
  1187.         kind = (int) tup[1];
  1188.         nam_list = (Tuple) tup[2];
  1189.  
  1190.         if (kind == as_with)
  1191.             with_clause(nam_list, context_node);
  1192.     ENDFORTUP(ft1);
  1193.  
  1194.     FORTUP(un_node=(Node), use_nodes, ft1);
  1195.         use_clause(un_node);
  1196.     ENDFORTUP(ft1);
  1197.     tup_free(use_nodes);
  1198.  
  1199.     FORTUP(name_node=(Node), elaborate_list, ft1);
  1200.         elaborate_pragma(name_node);
  1201.     ENDFORTUP(ft1);
  1202.  
  1203.     context = tup_add(inherited_context, context);
  1204. }
  1205.  
  1206. static void with_clause(Tuple nam_list, Node context_node)    /*;with_clause */
  1207. {
  1208.     char *nam, *unit;
  1209.     Fortup ft;
  1210.  
  1211.     FORTUP(nam=(char *), nam_list, ft);
  1212.         unit = get_unit(nam);
  1213.         if (strlen(unit) >0 )
  1214.             all_vis = tup_with(all_vis, unit);
  1215.         else {
  1216.             errmsg_str("Unknown unit in with clause: %", nam, "10.1.1",
  1217.               context_node);
  1218.             all_vis = tup_with(all_vis, strjoin("sp", nam));
  1219.         }
  1220.     ENDFORTUP(ft);
  1221. }
  1222.  
  1223. static char *get_unit(char *nam)                /*;get_unit*/
  1224. {
  1225.     int    exists, i;
  1226.     char    *unit, *unit1, *unit2, *su, *body_name;
  1227.     Fortup    ft1;
  1228.     Node    id_node;
  1229.     Symbol    namsym, unit_unam, scope;
  1230.     Tuple    s_info, decscopes, decmaps;
  1231.     Unitdecl ud;
  1232.  
  1233.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  get_unit");
  1234.  
  1235.     exists = FALSE;
  1236.     for(i = 1; i <= unit_numbers; i++) {
  1237.         unit = pUnits[i]->libUnit;
  1238.         unit2 = unit_name_name(unit);
  1239.         unit1 = unit_name_type(unit);
  1240.         if (streq(unit2, nam)
  1241.           && (streq(unit1, "ss") || streq(unit1, "sp"))) {
  1242.             exists = TRUE;
  1243.             break;
  1244.         }
  1245.     }
  1246.     if (exists == FALSE) {
  1247.         su = strjoin("su", nam);
  1248.         for(i = 1; i <= unit_numbers; i++) {
  1249.             unit = pUnits[i]->libUnit;
  1250.             if (streq(su, unit)) {
  1251.                 exists = TRUE;
  1252.                 break;
  1253.             }
  1254.         }
  1255.     }
  1256.  
  1257.     if (exists) {
  1258.         if (cdebug2 > 3) TO_ERRFILE(strjoin("unit ", unit));
  1259.  
  1260.         if (streq(unit_name_type(unit), "sp")) {
  1261.             /* puts created symbol in standard0 scope*/
  1262.             unit_unam = get_specs(nam);
  1263.  
  1264.             namsym = dcl_get(DECLARED(symbol_standard0), nam);
  1265.             if (NATURE(unit_unam) != na_generic_package
  1266.               && NATURE(unit_unam) != na_generic_package_spec)
  1267.                 vis_mods =tup_with(vis_mods, (char *) namsym);
  1268.         }
  1269.         else {    /* unit is a subprogram */
  1270.             if (retrieve(unit) ) {
  1271.                 /*    [unit_unam, s_info, decmap] := UNIT_DECL(unit); */
  1272.                 ud = unit_decl_get(unit);
  1273.                 unit_unam  = ud->ud_unam;
  1274.                 s_info     = ud->ud_symbols;
  1275.                 decscopes  = ud->ud_decscopes;
  1276.                 decmaps    = ud->ud_decmaps;
  1277.  
  1278.                 /* Restore symbol table entries.*/
  1279.                 symtab_restore(s_info);
  1280.  
  1281.                 /* (for decls = decmap(scope)) 
  1282.                  *    declared(scope) := decls; 
  1283.                  * end; 
  1284.                  */
  1285.                 FORTUPI(scope=(Symbol), decscopes, i, ft1);
  1286.                     DECLARED(scope) = dcl_copy((Declaredmap) decmaps[i]);
  1287.                 ENDFORTUP(ft1);
  1288.             }
  1289.             dcl_undef(DECLARED(symbol_standard0), nam);
  1290.             dcl_put(DECLARED(symbol_standard0), nam, unit_unam);
  1291.         }
  1292.         /* for generic specs retrieve body info */
  1293.         if (NATURE(unit_unam) == na_generic_package_spec) {
  1294.             body_name = strjoin("bo", nam);
  1295.             if (retrieve(body_name)) {
  1296.                 ud = unit_decl_get(body_name);
  1297.                 unit_unam = ud->ud_unam;
  1298.                 s_info = ud->ud_symbols;
  1299.                 decscopes = ud->ud_decscopes;
  1300.                 decmaps = ud->ud_decmaps;
  1301.  
  1302.                 /* SYMTAB restore */
  1303.                 symtab_restore(s_info);
  1304.  
  1305.                 FORTUPI(scope=(Symbol), decscopes, i, ft1);
  1306.                     if (decmaps[i] != (char *)0)
  1307.                         DECLARED(scope) = dcl_copy((Declaredmap) decmaps[i]);
  1308.                 ENDFORTUP(ft1);
  1309.             }
  1310.         }
  1311.         else if (NATURE(unit_unam) == na_generic_procedure_spec
  1312.           || NATURE(unit_unam) == na_generic_function_spec) {
  1313.             body_name = strjoin("su", nam);
  1314.             /* CHECK HOW MUCH OF THIS IS NECESSARY !!! */
  1315.             if (retrieve(body_name)) {
  1316.                 ud = unit_decl_get(body_name);
  1317.                 unit_unam  = ud->ud_unam;
  1318.                 s_info     = ud->ud_symbols;
  1319.                 decscopes  = ud->ud_decscopes;
  1320.                 decmaps    = ud->ud_decmaps;
  1321.  
  1322.                 /* Restore symbol table entries.*/
  1323.                 symtab_restore(s_info);
  1324.  
  1325.                 /* (for decls = decmap(scope)) 
  1326.                  *    declared(scope) := decls; 
  1327.                  * end; 
  1328.                  */
  1329.                 FORTUPI(scope=(Symbol), decscopes, i, ft1);
  1330.                     DECLARED(scope) = dcl_copy((Declaredmap) decmaps[i]);
  1331.                 ENDFORTUP(ft1);
  1332.             }
  1333.             dcl_undef(DECLARED(symbol_standard0), nam);
  1334.             dcl_put(DECLARED(symbol_standard0), nam, unit_unam);
  1335.         }
  1336.         return unit;
  1337.     }
  1338.     else {         /* Unit is not in library*/
  1339.         id_node = node_new(as_simple_name);
  1340.         N_VAL(id_node) = (char *) nam;
  1341.         check_old(id_node);
  1342.         if (N_UNQ(id_node) == symbol_undef) {     /* safe to add it, */
  1343.             namsym = find_new(N_VAL(id_node));    /* To avoid error */
  1344.             N_UNQ(id_node) = namsym;
  1345. #ifdef TBSL
  1346.             visible(nam) :
  1347.             = {
  1348.             };              
  1349.             $ in subsequent USE
  1350. #endif
  1351.         }
  1352.         return strjoin("","");
  1353.     }
  1354. }
  1355.  
  1356. static void elaborate_pragma(Node node)                    /*;elaborate_pragma*/
  1357. {
  1358.     Node    arg_list_node;
  1359.     Node    i_node, e_node, name_node, arg_node;
  1360.     Tuple    arg_list;
  1361.     Fortup    ft1;
  1362.     char    *nam;
  1363.  
  1364.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : elaborate_pragma");
  1365.  
  1366.     arg_list_node = N_AST2(node);
  1367.     arg_list = N_LIST(arg_list_node);
  1368.     FORTUP(arg_node=(Node), arg_list, ft1);
  1369.         i_node    = N_AST1(arg_node);
  1370.         e_node = N_AST2(arg_node);
  1371.         /*For now, disregard named associations.*/
  1372.         if (cdebug2 > 3) TO_ERRFILE("all_vis : ");
  1373.         name_node = N_AST1(e_node);       /* extract simple_name node.*/
  1374.         nam = N_VAL(name_node);
  1375.         if (tup_memstr(strjoin("sp", nam), all_vis)) {
  1376.             /*if ['spec', nam] in all_vis then*/
  1377.             elab_pragmas =tup_with(elab_pragmas, strjoin("bo", nam));
  1378.             /* package body needed.*/
  1379.         }
  1380.         else if (tup_memstr(strjoin("ss", nam), all_vis)) {
  1381.             elab_pragmas =tup_with(elab_pragmas, strjoin("su", nam));
  1382.             /* subprogram body needed.*/
  1383.         }
  1384.         else if (tup_memstr(strjoin("su", nam), all_vis)) {
  1385.             ;    /* already listed.*/
  1386.         }
  1387.         else {
  1388.             warning(strjoin(strjoin(
  1389.                  "Unknown unit name in ELABORATE pragma ", nam),
  1390.               "10.5"), name_node);
  1391.         }
  1392.     ENDFORTUP(ft1);
  1393. }
  1394.  
  1395. void stub_head(int nat, Node id_node)                        /*;stub_head*/
  1396. {
  1397.     /* Find unique name of package or task stub, and verify that it occurs
  1398.      * in the proper scope.
  1399.      */
  1400.  
  1401.     char    *id;
  1402.     Symbol    stub_name;
  1403.  
  1404.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  stub_head");
  1405.  
  1406.     find_old(id_node);
  1407.     id = N_VAL(id_node);
  1408.     stub_name = N_UNQ(id_node);
  1409.  
  1410.     if (SCOPE_OF(stub_name) != scope_name ) {
  1411.         errmsg_str("specification and stub for % are in different scopes", id,
  1412.           "7.1, 9.1", id_node);
  1413.     }
  1414.  
  1415.     /* Nature of specification must match that of stub.*/
  1416.  
  1417.     if ((nat == na_package && (NATURE(stub_name) != na_package_spec
  1418.       && NATURE(stub_name) != na_generic_package_spec))
  1419.       || (nat == na_task && (NATURE(stub_name) != na_task_type_spec
  1420.       && NATURE(stub_name) != na_task_obj_spec)) ) {
  1421.         errmsg_str("Matching specification not found for stub %", id,
  1422.           "7.1, 9.1", id_node);
  1423.         if (DECLARED(stub_name) == (Declaredmap)0) 
  1424.             DECLARED(stub_name) = dcl_new(0);
  1425.     }
  1426. }
  1427.  
  1428. void save_stub(Node node)                            /*;save_stub*/
  1429. {
  1430.     char    *kind, *stub_name;
  1431.     char    *other_unit;
  1432.     Symbol    name, unit_unam;
  1433.     Node    spec_node, id_node, stmt_node;
  1434.     Tuple    env_scope_st, tup;
  1435.     Fortup    ft1;
  1436.     int    i, si;
  1437.     Stubenv ev;
  1438.  
  1439.     if (N_KIND(node) ==  as_subprogram_stub) {
  1440.         spec_node = N_AST1(node);
  1441.         stmt_node = N_AST3(node);
  1442.         id_node = N_AST1(spec_node);
  1443.         kind = "su";
  1444.         /* Transform the node to as_subprogram_stub_tr nearby dropping off the
  1445.          * specification part which contains unnecessary conformance info (in
  1446.          * the formal part). Also the node as_procedure (as_function) is 
  1447.          * unnecessary since this can be determined from the symbol table. Now 
  1448.          * we move the id_node info (name of the subprogram) to the 
  1449.          * as_subprogram_stub_tr node directly and move the statments node to
  1450.          * the N_AST1 field so that the N_UNQ field (N_AST3) can be used.
  1451.          */
  1452.         N_KIND(node) = as_subprogram_stub_tr;
  1453.         N_AST1(node) = stmt_node;
  1454.         N_UNQ(node) = N_UNQ(id_node);
  1455.     }
  1456.     else {            /* package or task stub */
  1457.         id_node = node;
  1458.         kind  = "bo";
  1459.     }
  1460.  
  1461.     /* Save current state of compilation : scope stack and related declared
  1462.      * maps, for a subprogram or module stub.
  1463.      */
  1464.     name = N_UNQ(id_node);
  1465.  
  1466.     if (cdebug2 > 3) TO_ERRFILE(strjoin("save_stub: ", original_name(name)));
  1467.  
  1468.     /* In order to uniquely identify the stub, we create for it a name which
  1469.      * includes the names of all surrounding scopes, with the exception of
  1470.      * the ever-present standard environment and its enclosing scope.
  1471.      */
  1472.     stub_name = strjoin(kind, original_name(name));
  1473.     i = tup_size(open_scopes)-2;
  1474.     stub_name = strjoin(stub_name, ".");
  1475.     stub_name = strjoin(stub_name, original_name((Symbol) open_scopes[1]));
  1476.     if (i != 1) {
  1477.         stub_name = strjoin(stub_name, ".");
  1478.         stub_name = strjoin(stub_name, original_name((Symbol) open_scopes[i]));
  1479.     }
  1480.     /* Ada requires that the identifiers of all subunits of a given library
  1481.      * unit (as well as the name of the library unit itself) be unique.
  1482.      * Check to see of there exists another sub_unit that has the same
  1483.      * identifier a different parent but the same eldest ancestor.
  1484.      */
  1485.     FORTUP(other_unit=(char *), lib_stub, ft1);
  1486.         if (streq(unit_name_name(other_unit), unit_name_name(stub_name))
  1487.           && streq(stub_ancestor(other_unit), stub_ancestor(stub_name)))
  1488.         errmsg("Subunit identifier not unique", "10.2", id_node);
  1489.     ENDFORTUP(ft1);
  1490.  
  1491.     /* Verify that the stub appears immediately within a compilation unit.*/
  1492.     if (!streq(original_name(scope_name), unit_name_name(unit_name)))
  1493.         errmsg_l("stubs can only appear in the outermost scope of a " ,
  1494.           "compilation unit", "10.2", id_node);
  1495.  
  1496.     /* Install the new stub into the library. */
  1497.     update_lib_maps(stub_name, 's');
  1498.  
  1499.     /* Save stub environment. 
  1500.      * Perhaps some optimization can be done by have a pointer to the symbol 
  1501.      * table of the parent instead of a complete copy for each stub.
  1502.      *
  1503.      * open_decls := {};
  1504.      * (forall decl = declared(os))
  1505.      *    open_decls(os) := {[nam, decl(nam), SYMBTABF(decl(nam))] :
  1506.      *            nam in domain decl};
  1507.      * end forall;
  1508.      */
  1509.  
  1510.     /*unit_unam := declared('STANDARD#0')(stub_name(#stub_name)); */
  1511.     unit_unam = dcl_get(DECLARED(symbol_standard0), stub_ancestor(stub_name));
  1512.  
  1513.     env_scope_st = tup_new(0);
  1514.     FORTUP(tup=(Tuple), scope_st, ft1);
  1515.         env_scope_st = tup_with(env_scope_st, (char *) tup_copy(tup));
  1516.     ENDFORTUP(ft1);
  1517.     tup = tup_new(4);
  1518.     tup[1] = (char *) scope_name;
  1519.     tup[2] = (char *) tup_copy(open_scopes);
  1520.     tup[3] = (char *) tup_copy(used_mods);
  1521.     tup[4] = (char *) tup_copy(vis_mods);
  1522.     env_scope_st = tup_with(env_scope_st, (char *) tup);
  1523.     /* STUB_ENV(stub_name) :=
  1524.      * [ (scope_st + [scope_info]),
  1525.      *   open_decls,
  1526.      *   {[vm, visible(vm)] : vm in vis_mods | vm notin ignore},
  1527.      *   unit_unam,
  1528.      *   SYMBTABF(unit_unam),
  1529.      *   CONTEXT
  1530.      *  ];
  1531.      */
  1532.     ev = (Stubenv) stubenv_new();
  1533.     ev->ev_scope_st = env_scope_st;
  1534.     ev->ev_open_decls = unit_symbtab(unit_unam, 's');
  1535.     ev->ev_nodes = tup_copy(unit_nodes);
  1536.     ev->ev_unit_unam = unit_unam;
  1537.     ev->ev_decmap = dcl_copy(DECLARED(unit_unam));
  1538.     ev->ev_context = tup_copy(context);
  1539.  
  1540.     if (NATURE(name) == na_task_obj_spec)
  1541.         /* Task object. The stub applies to the task type, not the object. */
  1542.         N_UNQ(id_node) = TYPE_OF(name);
  1543.  
  1544.     N_VAL(node) = stub_name;
  1545.     /* Install pointer to saved stub environment */
  1546.     si = stub_numbered(stub_name);
  1547.     tup = (Tuple) stub_info[si];
  1548.     tup[2] = (char *) ev;
  1549.     stub_parent_put(stub_name, unit_name);
  1550.     stubs_to_write = set_with(stubs_to_write, (char *) si);
  1551.  
  1552.     /* allocate a fake proper body for the stub. Needed for handling of
  1553.      * generic stubs.
  1554.      */
  1555.     si = unit_number(stub_name);
  1556.     pUnits[si]->libInfo.obsolete = string_ds; /*"$D$"*/
  1557. }
  1558.  
  1559. static Tuple check_separate(Node unit_node)                /*;check_separate*/
  1560. {
  1561.     /* This procedure restores the environment saved for a stub,
  1562.      * including the original scope stack.
  1563.      */
  1564.  
  1565.     Node    a_node, proper_node, spec, name_node;
  1566.     char    *name, *parent_unit, *outer_most;
  1567.     int    parent_num;
  1568.     Symbol    unit_unam;
  1569.     Stubenv ev;
  1570.  
  1571.     a_node    = N_AST1(unit_node);
  1572.     proper_node = N_AST2(unit_node);
  1573.  
  1574.     /*  Find identifier of subunit. */
  1575.     if (N_KIND(proper_node) == as_subprogram) {
  1576.         spec = N_AST1(proper_node);
  1577.         name_node = N_AST1(spec);
  1578.     }
  1579.     else     /* package body.*/
  1580.         name_node = N_AST1(proper_node);
  1581.     name = N_VAL(name_node);
  1582.  
  1583.     if (cdebug2 > 3) TO_ERRFILE(strjoin("checking separate: ", name));
  1584.  
  1585.     ev = (Stubenv) retrieve_env(a_node, name_node);
  1586.     if (ev != (Stubenv)0) {
  1587.         scope_st = ev->ev_scope_st;
  1588.         unit_unam = ev->ev_unit_unam;
  1589.         parent_num = stub_parent_get(unit_name);
  1590.         parent_unit = pUnits[parent_num]->name;
  1591.         all_vis = tup_with(all_vis, (char *)parent_unit);
  1592.         /* put name of outer-most scope in standard*/
  1593.         outer_most = stub_ancestor(unit_name);
  1594.         dcl_undef(DECLARED(symbol_standard0), outer_most);
  1595.         dcl_put(DECLARED(symbol_standard0), outer_most, unit_unam);
  1596.  
  1597.         /* Reestablish scope of the parent unit, in which compilation of the
  1598.          * subunit will take place.
  1599.          */
  1600.         popscope();
  1601. #ifdef TBSL
  1602.         /* Initialize visibility info. */
  1603.         (forall vis_vm = vis(vm))
  1604.             visible(vm) :
  1605.         = vis_vm;
  1606.         declared(vm) :
  1607.         = vis_vm;
  1608.         end forall;
  1609. #endif
  1610.         DECLARED(unit_unam) = dcl_copy(ev->ev_decmap);
  1611.         symtab_restore(ev->ev_open_decls);
  1612.         return ev->ev_context;
  1613.     }
  1614.     else return (Tuple)0; /* to indicate error */
  1615. }
  1616.  
  1617. static Stubenv retrieve_env(Node a_node, Node name_node)    /*;retrieve_env*/
  1618. {
  1619.     /* Obtain the sequence of parent units of the  subunit. It may be an
  1620.      * expanded name listing all ancestors.
  1621.      */
  1622.  
  1623.     Node    id_node;
  1624.     char    *name, *expd_name, *stub_nam, *stub_name;
  1625.     Fortup    ft1;
  1626.     Tuple    tup;
  1627.     int    si, stub_err;
  1628.  
  1629.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  retrieve_env");
  1630.  
  1631.     name = N_VAL(name_node);
  1632.     expd_name = strjoin(name, "");
  1633.     if (N_KIND(a_node) != as_simple_name) {
  1634.         id_node = N_AST2(a_node);
  1635.         expd_name = strjoin(expd_name, ".");
  1636.         expd_name = strjoin(expd_name, N_VAL(id_node));
  1637.     }
  1638.     while (N_KIND(a_node) != as_simple_name) a_node = N_AST1(a_node);
  1639.     expd_name = strjoin(expd_name, ".");
  1640.     expd_name = strjoin(expd_name, N_VAL(a_node));
  1641.     /* retrieve from library the environment in which a stub was
  1642.      * first seen.
  1643.      */
  1644.  
  1645.     stub_err = FALSE;
  1646.     stub_name = (char *) 0;
  1647.     FORTUP(stub_nam=(char *), lib_stub, ft1);
  1648.         if (streq(unit_name_names(stub_nam), expd_name)) {
  1649.             if (stub_name == (char *)0) stub_name = stub_nam;
  1650.             else if (!streq(stub_name, stub_nam)) stub_err = TRUE;
  1651.         }
  1652.     ENDFORTUP(ft1);
  1653.  
  1654.     if (stub_name == (char *) 0) stub_err = TRUE;
  1655.  
  1656.     if (stub_err || !stub_retrieve(stub_name)) {
  1657.         errmsg_str("cannot find stub for subunit %", name, "10.2" , name_node);
  1658.         unit_name = strjoin("","");
  1659.         return (Stubenv)0;
  1660.     }
  1661.     remove_obsolete_stubs(expd_name);
  1662.     unit_name = strjoin(stub_name, "");
  1663.     seq_symbol_n = 0;
  1664.     init_compunit();
  1665.     si = stub_number(stub_name);
  1666.     tup = (Tuple) stub_info[si];
  1667.     return (Stubenv) tup[2];
  1668. }
  1669.  
  1670. static void remove_obsolete_stubs(char *name) /*;remove_obsolete_stubs*/
  1671. {
  1672.     /* If this unit was previously compiled remove possible obsolete stubs 
  1673.      * of it from library.
  1674.      */
  1675.  
  1676.     char     *stub;
  1677.     Fortup  ft1;
  1678.  
  1679.     FORTUP(stub=(char *), lib_stub, ft1);
  1680.         if (streq(stub_ancestors(stub), name))
  1681.             lib_stub_put(stub, (char *)0);
  1682.     ENDFORTUP(ft1);
  1683. }
  1684.